perm filename BEXPR.SAI[PNT,HE]2 blob
sn#417611 filedate 1979-02-10 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00018 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 ENTRY
C00005 00003 ! miscellaneous definitions
C00010 00004 ! expression builders: exp,bfact,bterm,aexp,term,factor,pfactor
C00019 00005 ! expression builders: hash,hashindex,new_expr,check_expr
C00021 00006 ! expression builders: opcode, idcode, cncode,arcode,prcode
C00033 00007 ! buffer definitions, ipush,fpush,gpush,ppush,cpush
C00035 00008 ! αexpr$,βexpr$,nexpr,expr$11,expr$2,expr$off,αten$
C00040 00009 ! mkexpr,gtexpr,aref,idref,pref
C00044 00010 ! $append,$aappend
C00048 00011 ! pdp10 routines: ,$ASGPCODE
C00053 00012 ! printing: prnpcode,prvpcode,ddt
C00054 00013 ! motion:$centerpcode,$movepcode,$drivepcode,rforcepcode
C00059 00014 ! control pcodes: if,for,while,do
C00062 00015 ! arrdclpcode,prcdclpcode,rtnpcode,smpdclpcode
C00067 00016 ! mssngr buffer procedures: getfp,getfpa,getin,getina
C00068 00017 ! assgmnt,unfixment,affixment,teninterpret
C00073 00018 ! $execute,$elfeval,$$gtvexpr,$$gtexpr
C00076 ENDMK
C⊗;
ENTRY;
BEGIN "FEXPR"
DEFINE $$PRGID=TRUE; DEFINE $EXPR=TRUE;
REQUIRE "HEADER.SAI" SOURCE_FILE;
REQUIRE "[][]" DELIMITERS;
REQUIRE 300 STRING_PDL;REQUIRE 1000 SYSTEM_PDL;
REQUIRE 10000 STRING_SPACE;
DEFINE
#DTYPES=5;
IFC #DEBUG THENC
PROCEDURE pPPCODE;ppcode(null_record);
ENDC
! PROCEDURE FOR CONVERTING A FLOATING POINT NUMBER IN 11 FORMAT ;
! plagiarized from BES in move.sai;
PROCEDURE FLTOUT(REAL FNUM; REFERENCE INTEGER XNUM1,XNUM2);
BEGIN
LABEL ST1,ST2,OVER,FLTEND;
INTEGER BYTE,NUM1,NUM2;
BYTE←'013200000002;
START_CODE
MOVE 2,FNUM;
JUMPGE 2,ST1;
MOVN 2,2;
TLO 2,'400000;
ST1: JFCL 2,ST2;
ST2: ADDI 2,4;
JFCL 2,OVER;
DPB 2,BYTE;
SETZ 1,;
LSHC 1,16;
MOVEM 1,NUM1;
SETZ 1,;
LSHC 1,16;
MOVEM 1,NUM2;
END;
XNUM1←NUM1;
XNUM2←NUM2;
GOTO FLTEND;
OVER: OUTSTR("ERROR-ROUNDING OVERFLOW"&CRLF);
FLTEND: END;
! miscellaneous definitions ;
PRELOAD_WITH "SCALAR","VECTOR","ROT","TRANS","FRAME";
STRING ARRAY DTYPES[1:5];
PRELOAD_WITH 0,#SC,#VT,#RT,#RT,#RT,0,0;
INTEGER ARRAY OBTYPES[0:7];
COMMENT TEMPORARY EXPR RECORD USED INTERNALLY BY THESE ROUTINES;
RCLASS !!EXPR(INTEGER OP,X1,X2; INTEGER TYPE,#EL; RPTR(!!EXPR)SON,BRO);
! OP is opcode, x1,x2 are used to represent floating point numbers in 11 format
x1 along is used for index of array
x2 is used for leveloffset of array;
INTEGER ##EL;
DEFINE II=0;
DEFINE MAKEOP(OPNUM,OPNAM)"[]"=
[ REDEFINE II = II + 2 ;
DEFINE OPNUM = II ; ];
REQUIRE "MOVE.DEF[PNT,HE]" SOURCE_FILE;
REQUIRE "INTOPS.SAI" SOURCE_FILE;
DEFINE #ALINTOPS = II ;
REQUIRE "OPDEC2.SAI" SOURCE_FILE;
DEFINE TOKEN_INDEX = [TOKENINDEX],TOKEN_CLASS=[tokenclass],ID_CLASS=[TOKEN_INDEX];
INTEGER BRCHAR,SPBR;
REDEFINE ZZ(ARG0,ARG1,ARG2)=[ARG0,] ;
preset_array(CODE_OP, OP_LIST,STRING, 1, #PNTINTOPS);
REDEFINE ZZ(ARG0,ARG1,ARG2)=[ARG2,];
preset_array(CODE_LEVEL,OP_LIST,INTEGER,1,#PNTINTOPS);
REDEFINE XXCOUNT=0;
REDEFINE ZZ(ARG1,ARG2,ARG3)=[];
REDEFINE XXX(ARGNAME,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[
REDEFINE XXCOUNT=XXCOUNT + 1;];
OP_LIST;
DEFINE XXARG=0;
REDEFINE ZZ(ARG1,ARG2,ARG3)=[ REDEFINE XXARG=XXARG + 1;];
REDEFINE XXX(ARGNAME,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[
REDEFINE XXVAL = ((((XXARG*#DTYPES)+ARG1)*#DTYPES+ARG2)*#DTYPES+ARG3);
XXVAL,
];
DEFINE #HASHTAB=XXCOUNT;
PRESET_ARRAY(HASHTAB, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGTYPE,ARGORDER,ARG1,AR2,ARG)=[
IFCR ¬DECLARATION(ARGNAME) THENC
REQUIRE "UNDEFINED OP:: "&CVPS(ARGNAME)&"
" MESSAGE;
ENDC];
OP_LIST;
REDEFINE XXX(ARGNAME,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[
IFCR ¬DECLARATION(ARGNAME) THENC
MAKEOP(ARGNAME)
ENDC ARGNAME,];
PRESET_ARRAY(PCODE, OP_LIST, INTEGER, 1, #HASHTAB);
REDEFINE XXX(ARGNAME,ARGTYPE,ARGORDER,ARG1,ARG2,ARG3)=[ARGTYPE,];
PRESET_ARRAY(OPTYPE, OP_LIST, INTEGER, 1, #HASHTAB);
PROCEDURE GGTOKEN(BOOLEAN FLAG(TRUE));
α INTEGER I;
GTOKEN(FLAG);
FOR I←1 STEP 1 UNTIL #PNTINTOPS
DO IF EQU(TOKEN,CODE_OP[I])
THEN BEGIN
#TOKEN←OPERATOR_TYPE;
TOKEN_CLASS←CODE_LEVEL[I];
TOKEN_INDEX←I;
RETURN;
END;
IF EQU(TOKEN,0) THEN #TOKEN←UNDECLARED_TYPE;
β;
FORWARD RPTR (!!EXPR) PROCEDURE OPCODE(INTEGER OP,NARGS; RPTR(!!EXPR)EPTR);
FORWARD RPTR (!!EXPR) PROCEDURE CNCODE(REAL VAL);
FORWARD RPTR (!!EXPR) PROCEDURE IDCODE(RPTR(SYMBOL)SYMPTR);
FORWARD RECURSIVE RPTR (!!EXPR) PROCEDURE ARCODE(RPTR(SYMBOL)PTR;INTEGER OPERATION(XGTVAL));
FORWARD RECURSIVE RPTR(!!EXPR)PROCEDURE VPRCODE(RPTR(SYMBOL)PRSYM);
! expression builders: exp,bfact,bterm,aexp,term,factor,pfactor;
! EXP E: BF { OR BF }
BFACT BF: BT { AND BT }
BTERM BT: AE | AE <REL> AE
AEXP AE: {+|-} T {+|- T }
TERM T: F {*|/ F}
FACTOR F: PF or PF↑PF
PFACTOR PF: ( E ) or | E | or func(E,E,E,..) or <constant> or <id> or ¬ PF;
DEFINE EXP= [XXXXX(EXP_XX)];
! FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE EXP XXXXX(EXP_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BEFACT XXXXX(BEFACT_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BFACT XXXXX(BFACT_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE BTERM XXXXX(BTERM_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE AEXP XXXXX(AEXP_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE TERM XXXXX(TERM_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE FACTOR XXXXX(FACTOR_XX)
FORWARD RECURSIVE RPTR(!!EXPR) PROCEDURE PF XXXXX(PF_XX);
RECURSIVE RPTR(!!EXPR) PROCEDURE XXXXX(INTEGER LEVEL);
α RPTR(!!EXPR)$$1,$$2,$$3; INTEGER I,I2;
CASE LEVEL OF
α
[BEFACT_XX] [BFACT_XX] [AEXP_XX] [TERM_XX]
α
IF LEVEL=AEXP_XX AND #TOKEN=OPERATOR_TYPE
AND TOKEN_CLASS= AEXP_XX THEN
α I←TOKEN_INDEX;
GGTOKEN; $$1←XXXXX(LEVEL + 1);
$$1←OPCODE(I,1,$$1);
β
ELSE $$1←XXXXX(LEVEL+1);
WHILE #TOKEN=OPERATOR_TYPE AND TOKEN_CLASS=LEVEL DO
α I←TOKEN_INDEX;
GGTOKEN; !!EXPR:BRO[$$1] ← XXXXX(LEVEL + 1);
$$1←OPCODE(I,2,$$1);
β;
β;
[EXP_XX] [BTERM_XX] [FACTOR_XX]
α
$$1←XXXXX(LEVEL + 1);
IF (#TOKEN=OPERATOR_TYPE OR #TOKEN=RES_TYPE) AND TOKEN_CLASS=LEVEL
THEN
α I←TOKEN_INDEX;
GGTOKEN; !!EXPR:BRO[$$1]←XXXXX(LEVEL + 1);
$$1←OPCODE(I,2,$$1);
β;
β;
[PF_XX]
CASE #TOKEN OF
α "CASE #TOKEN"
[REAL_TYPE]
[INT_TYPE]
α INTEGER I;
$$1←CNCODE(REALSCAN(TOKEN,I)); GGTOKEN(FALSE); β;
[ID_TYPE]
α
CASE SYMBOL:ACCESS[TOKENPTR] OF
α
[#SIMPLE] $$1←IDCODE(TOKENPTR);
[#ARRAY] $$1←ARCODE(TOKENPTR);
[#PROCEDURE] $$1←VPRCODE(TOKENPTR)
β;
GGTOKEN(FALSE); β ;
[OPERATOR_TYPE]
CASE TOKEN_INDEX OF
α "CASE TOKEN_INDEX"
[LPAREN_X]
α "LPAREN_X"
GGTOKEN; $$2←$$1←EXP; I2←1;
IF TOKEN≠")"
THEN WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP;
I2←I2+1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")" THEN
ERROR("MISMATCHED PAREN")
ELSE GGTOKEN(FALSE);
IF I2≠1 THEN $$1←OPCODE(IMPLICIT_X,I2,$$1);
β "LPAREN_X";
[MAGNITUDE_X]
α GGTOKEN; $$1←EXP;
IF TOKEN="|"
THEN GGTOKEN(FALSE)
ELSE ERROR("MISMATCHED VERT BAR");
$$1←OPCODE(MAGNITUDE_X,1,$$1);
β;
[STOS_X][DOWNARROW_X][DOLLAR_X][ALPHA_X]
α INTEGER I; I←TOKEN_INDEX;
GGTOKEN; $$1←EXP;
$$1←OPCODE(I,1,$$1);
β;
ELSE
α I←TOKEN_INDEX; IF TOKEN_CLASS≠LEVEL
THEN ERROR(TOKEN&" is not a valid term in an expression");
GGTOKEN;
IF TOKEN≠"(" THEN ERROR("REQUIRE LEFT PAREN") ELSE GGTOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP; I2←I2 + 1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")" THEN ERROR("MISMATCHED PAREN") ELSE GGTOKEN(FALSE);
$$1←OPCODE(I,I2,$$1);
β
β "CASE TOKEN_INDEX";
[RES_TYPE]
IFC FALSE THENC [RES_TYPE]
IF TOKEN_INDEX=EVAL_X
THEN α RPTR(TREE) $TR; STRING S;RPTR(ANY_CLASS)TEMP;
EXPRESSION_STRING←EXPRESSION_STRING[1 TO ∞-4]&"{ "&TOKEN;
GGTOKEN;
IF TOKEN≠"(" THEN ERROR("REQUIRE LEFT PAREN")
ELSE $TR←GTEXPR;
$$1←MK_EXPR(TEMP←TREE:DATA[$TR],TREE:DTYPE[$TR]);
CASE TREE:DTYPE[$TR] OF
BEGIN "CASE"
[#SC] S← CVGX(SCALAR:VALUE[TEMP]);
[#VT] S← STR_VT(VECTOR:XC[TEMP],
VECTOR:YC[TEMP],(VECTOR:ZC[TEMP]),8);
[#RT] S←STR_RT(ROT:XF[TEMP]);
[#FR] S←"FRAME "&STR_TR(FRAME:XF[TEMP],1,8);
[#TR] S←STR_TR(TRANS:XF[TEMP],1,8)
END "CASE";
GGTOKEN;
IF TOKEN≠")" THEN ERROR("REQUIRE RIGHT PAREN")
ELSE
EXPRESSION_STRING←EXPRESSION_STRING&" = } "&S;
GGTOKEN(FALSE);
β
ELSE
ENDC
α I←TOKEN_INDEX; IF TOKEN_CLASS≠LEVEL
THEN ERROR(TOKEN&" is not a valid term in an expression");
GGTOKEN;
IF TOKEN≠"("
THEN ERROR("REQUIRE LEFT PAREN")
ELSE GGTOKEN;
$$2←$$1←EXP; I2←1;
WHILE TOKEN="," DO
α GGTOKEN; $$3←EXP; I2←I2 + 1;
$$2←(!!EXPR:BRO[$$2]←$$3);
β;
IF TOKEN≠")"
THEN ERROR("MISMATCHED PAREN")
ELSE GGTOKEN(FALSE);
$$1←OPCODE(I,I2,$$1);
β;
IFC FALSE THENC
[UNDECLARED_TYPE]
IF FN_CUR=NULL_RECORD THEN ERROR("UNEXPECTED TOKEN FOUND")
ELSE
α
INTEGER I;
FOR I←1 STEP 1 UNTIL FUNCTION:NARGS[FN_CUR]
DO IF EQU(TOKEN,FUNCTION:ARGNAME[FN_CUR][I])
THEN
α
$$1←MK_EXPR(FUNCTION:PTR[FN_CUR][I],#EX);
DONE;
β;
IF I> FUNCTION:NARGS[FN_CUR] THEN ERROR(TOKEN & " IS UNKNOWN");
GGTOKEN(FALSE);
β;
ENDC
ELSE α ERROR("UNEXPECTED TOKEN FOUND ⊂"&TOKEN&"⊃");
$$1←NEW_RECORD(!!EXPR);
β
β "CASE #TOKEN"
β;
RETURN($$1);
β;
! expression builders: hash,hashindex,new_expr,check_expr;
INTEGER PROCEDURE HASH(INTEGER OP; INTEGER ARRAY IX);
RETURN((((OP*#DTYPES + IX[1])*#DTYPES+IX[2])*#DTYPES +IX[3]));
INTEGER PROCEDURE HASHINDEX(INTEGER HASHVAL);
BEGIN
INTEGER INDEX,LB,UB;
LB←1;UB←#HASHTAB;
DO BEGIN
INDEX←(LB+UB)/2;
IF HASHTAB[INDEX]=HASHVAL THEN RETURN(INDEX)
ELSE IF HASHTAB[INDEX]>HASHVAL THEN UB←INDEX-1
ELSE LB←INDEX+1;
END UNTIL LB>UB;
RETURN(0);
END;
RPTR (!!EXPR) PROCEDURE NEW_EXPR(INTEGER OP; RPTR(!!EXPR) SON(NULL_RECORD),
BRO(NULL_RECORD),SELF(NULL_RECORD));
BEGIN
RPTR (!!EXPR) CUR;
IF SELF=NULL_RECORD THEN CUR←NEW_RECORD(!!EXPR) ELSE CUR←SELF;
!!EXPR:OP[CUR]←OP;
!!EXPR:SON[CUR]←SON;
!!EXPR:BRO[CUR]←BRO;
##EL←##EL + (!!EXPR:#EL[CUR]←1);
RETURN(CUR);
END;
INTEGER PROCEDURE CHECK_EXPR(INTEGER OP,NARGS; RPTR(!!EXPR)ARRAY EXPRRY);
BEGIN
COMMENT EXPPRY WILL BE OF SIZE [1:NARGS];
INTEGER I;
INTEGER ARRAY IX[1:3];
IF NARGS>3 THEN ERROR("More arguments for function "&CODE_OP[OP]&" than allowed");
ARRCLR(IX);
FOR I←1 STEP 1 UNTIL NARGS DO IX[I]←!!EXPR:TYPE[EXPRRY[I]];
I←HASHINDEX(HASH(OP,IX));
RETURN(I);
END;
! expression builders: opcode, idcode, cncode,arcode,prcode;
RPTR (!!EXPR) PROCEDURE OPCODE(INTEGER OP,NARGS; RPTR(!!EXPR)EPTR);
BEGIN
RPTR(!!EXPR)ARRAY EXPRRY[1:NARGS];
RPTR(!!EXPR) P1,P2;
INTEGER I;INTEGER PCODE_INDEX;
P1←EPTR;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN
EXPRRY[I]←P1;
P1←!!EXPR:BRO[P1];
END;
IF P1≠NULL_RECORD THEN ERROR("P1 should be null record");
IF (PCODE_INDEX←CHECK_EXPR(OP,NARGS,EXPRRY))=0
THEN BEGIN
STRING S; S←NULL;
FOR I←1 STEP 1 UNTIL NARGS DO
S←S&" "&DTYPES[!!EXPR:TYPE[EXPRRY[I]]]&",";
ERROR("operator/function "&CODE_OP[OP]&" cannot take operand(s)"&S[1 to ∞-1]);
END;
P1←NEW_RECORD(!!EXPR);
##EL←##EL + (!!EXPR:#EL[P1]←1);
!!EXPR:OP[P1]←PCODE[PCODE_INDEX];
!!EXPR:TYPE[P1]←OPTYPE[PCODE_INDEX];
!!EXPR:SON[P1]←EPTR;
RETURN(P1);
END;
RPTR (!!EXPR) PROCEDURE CNCODE(REAL VAL);
BEGIN "cncode"
COMMENT CODE TO HANDLE CONSTANTS;
RPTR(!!EXPR)E1;
E1←NEW_RECORD(!!EXPR);
##EL←##EL + (!!EXPR:#EL[E1]←3);
!!EXPR:TYPE[E1]←#SC;
!!EXPR:OP[E1]←XPUSHSCI;
FLTOUT(VAL,!!EXPR:X1[E1],!!EXPR:X2[E1]);
RETURN(E1);
END "cncode";
RPTR (!!EXPR) PROCEDURE IDCODE(RPTR(SYMBOL)SYMPTR);
BEGIN
! COMMENT CHANGE ID_OFFSET PART WHEN WE CAN DETERMINE ID_OFFSET DIRECTLY;
RPTR(!!EXPR)E1;
E1←NEW_RECORD(!!EXPR);
IF SYMBOL:INDEX[SYMPTR]>0 THEN
BEGIN "simply defined"
##EL←##EL + (!!EXPR:#EL[E1]←3);
!!EXPR:OP[E1]←XAGTVAL;
!!EXPR:X1[E1]←SYMBOL:INDEX[SYMPTR];
!!EXPR:X2[E1]←SYMBOL:OFFSET[SYMPTR];
END
ELSE BEGIN "for nonsimple symbols"
##EL←##EL+(!!EXPR:#EL[E1]←2);
!!EXPR:OP[E1]←XGTVAL;
!!EXPR:X1[E1]←SYMBOL:OFFSET[SYMPTR];
END;
!!EXPR:TYPE[E1]←SYMBOL:TYPE[SYMPTR];
RETURN(E1);
END;
RPTR(!!EXPR)PROCEDURE IDNDXCODE(RPTR(SYMBOL)PTR);
IF SYMBOL:INDEX[PTR]>0
THEN BEGIN RPTR(!!EXPR) E1;
E1←NEW_RECORD(!!EXPR);
!!EXPR:OP[E1]←XPUSHINTI;
!!EXPR:X1[E1]←SYMBOL:INDEX[PTR];
##EL←##EL+(!!EXPR:#EL[E1]←2);
RETURN(E1);
END
ELSE RETURN(NEW_EXPR(XNOOP));
RECURSIVE RPTR(!!EXPR)PROCEDURE ARNDXCODE(RPTR(SYMBOL)PTR);
BEGIN
! This procedure produces the tree form for the array
reference index. To get the full array reference
use arcode with the right argument GTVAL or CHNGE;
RPTR(!!EXPR)E2,E3;
INTEGER I;
GGTOKEN;
IF TOKEN≠"[" THEN ERROR("Need [ after array name");
GGTOKEN;
E2←EXP;
IF (E2=NULL_RECORD) OR (!!EXPR:TYPE[E2]≠#SC)
THEN ERROR("Index of Array must be scalar");
FOR I←2 STEP 1 UNTIL ARRAYREC:#DIM[SYMBOL:OBJECT[PTR]] DO
BEGIN
IF TOKEN≠"," THEN ERROR("Need comma between fields of array index");
GTOKEN;
IF ((E3←EXP)=NULL_RECORD) OR (!!EXPR:TYPE[E3]≠#SC)
THEN ERROR("Index of Array must be scalar");
!!EXPR:BRO[E3]←E2;
E2←E3;
END;
IF TOKEN≠"]" THEN ERROR("Need ] for bounds of array");
RETURN(E2);
END;
RECURSIVE RPTR(!!EXPR)PROCEDURE ARCODE(RPTR(SYMBOL)PTR; INTEGER OPERATION(XGTVAL));
BEGIN
RPTR(!!EXPR)E1;
IF (OPERATION≠XGTVAL) AND (OPERATION≠XCHNGE)
THEN ERROR("Error in ARCODE, OPERATION can take only XGTVAL or XCHNGE");
E1←NEW_RECORD(!!EXPR);
!!EXPR:OP[E1]←OPERATION;
!!EXPR:X1[E1]←SYMBOL:OFFSET[PTR];
!!EXPR:TYPE[E1]←SYMBOL:TYPE[PTR];
##EL←##EL+(!!EXPR:#EL[E1]←2);
!!EXPR:SON[E1]←ARNDXCODE(PTR);
RETURN(E1);
END;
RPTR(!!EXPR)PROCEDURE SPRCODE(RPTR(SYMBOL)PRSYM);
BEGIN
RPTR(!!EXPR)E1;
E1←NEW_RECORD(!!EXPR);
!!EXPR:OP[E1]←XPROC;
!!EXPR:X1[E1]←SYMBOL:OFFSET[PRSYM];
##EL←##EL+(!!EXPR:#EL[E1]←2);
RETURN(E1);
END;
RECURSIVE RPTR(!!EXPR)PROCEDURE PRCODE(RPTR(SYMBOL)PRSYM);
BEGIN "prcode"
INTEGER NARGS; RPTR(PROC)P;
RPTR(!!EXPR)EF;
NARGS←PROC:NARGS[P←SYMBOL:OBJECT[PRSYM]];
IF NARGS =0 THEN EF←SPRCODE(PRSYM)
ELSE BEGIN "procedure with arguments"
! E1,ETOP1 are pointers to the procedure call,
E0 refers to the arguments set up if they are values ;
RPTR(!!EXPR)E0,E1,ETOP1,ETMP,ETMP2; INTEGER I;
GGTOKEN;
IF TOKEN≠"(" THEN ERROR("Need open paren after procedure name "&SYMBOL:PNAME[PRSYM]);
ETOP1←E1←SPRCODE(PRSYM);
E0←NULL_RECORD;
FOR I←1 STEP 1 UNTIL NARGS DO
BEGIN "check each argument"
GGTOKEN;
IF PROC:ARGACCS[P][I] LAND #ARRTYP THEN
BEGIN "array argument found"
IF TOKENPTR=NULL_RECORD
THEN ERROR("Need array reference here")
ELSE IF SYMBOL:ACCESS[TOKENPTR]≠#ARRAY
THEN ERROR("Need array reference here")
ELSE IF ARRAYREC:#DIM[SYMBOL:OBJECT[TOKENPTR]]
≠PROC:ARGDIM[P][I]
THEN ERROR("array dimensions dont agree with declaration");
!!EXPR:BRO[E1]←(ETMP←NEW_EXPR(SYMBOL:OFFSET[TOKENPTR]));
E1←ETMP;
END "array argument found"
ifc false thenc if ref arg ELSE IF PROC:ARGACCS[P][I] LAND #REFTYP THEN
cannot take value BEGIN "reference argument found"
RPTR(SYMBOL)TPTR;
IF (TPTR←TOKENPTR)=NULL_RECORD
THEN ERROR("Reference variable expected")
ELSE IF NOT(SYMBOL:TYPE[TPTR] LAND PROC:ARGTYPE[P][I])
THEN ERROR("types do not agree on reference variable")
ELSE IF SYMBOL:ACCESS[TPTR]=#ARRAY
THEN ETMP←ARNDXCODE(TPTR)
ELSE ETMP←IDNDXCODE(TPTR);
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
!!EXPR:BRO[E1]←(ETMP←NEW_EXPR(SYMBOL:OFFSET[TPTR]));
E1←ETMP;
END "reference argument found"
ELSE BEGIN "value argument found"
ETMP←EXP;
IF NOT(!!EXPR:TYPE[ETMP] LAND PROC:ARGTYPE[P][I])
THEN ERROR("expression type does not agree with declared");
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
!!EXPR:BRO[E1]←(ETMP←NEW_EXPR(#MINUS1));
E1←ETMP; STOKEN←TRUE;
END "value argument found";
elsec ELSE BEGIN
ETMP←EXP;
IF NOT(!!EXPR:TYPE[ETMP] LAND PROC:ARGTYPE[P][I])
THEN ERROR("expression type does not agree with declaration");
IF (PROC:ARGACCS[P][I]=0) OR
(PROC:ARGACCS[P][I] LAND #REFTYP) AND
(!!EXPR:OP[ETMP]≠XAGTVAL) AND
(!!EXPR:OP[ETMP]≠XGTVAL)
THEN
BEGIN "value"
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
!!EXPR:BRO[E1]←(ETMP←NEW_EXPR(#MINUS1));
E1←ETMP; STOKEN←TRUE;
END "value"
ELSE BEGIN "reference"
IF !!EXPR:OP[ETMP]=XGTVAL THEN
BEGIN "xgtval"
ETMP2←NEW_EXPR(!!EXPR:X1[ETMP]);
!!EXPR:BRO[E1]←ETMP2;
E1←ETMP2;
ETMP←!!EXPR:SON[ETMP];
##EL←##EL-2;
IF ETMP THEN
BEGIN
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
END;
END "xgtval"
ELSE IF !!EXPR:OP[ETMP]=XAGTVAL
THEN
BEGIN "xagtval"
ETMP2←NEW_EXPR(!!EXPR:X2[ETMP]);
!!EXPR:BRO[E1]←ETMP2;
E1←ETMP2;
##EL←##EL-1;
!!EXPR:OP[ETMP]←XPUSHINTI;
!!EXPR:#EL[ETMP]←2;
!!EXPR:BRO[ETMP]←E0;
E0←ETMP;
END "xagtval"
ELSE ERROR("Disastrous error");
STOKEN←TRUE;
END "reference";
END; endc
GGTOKEN;
IF I<NARGS AND TOKEN≠"," THEN
BEGIN ERROR("Need comma between arguments"); GGTOKEN; END;
IF I=NARGS AND TOKEN≠")" THEN
ERROR("Need right paren after argument list");
END "check each argument";
EF←NEW_EXPR(XNOOP,NEW_EXPR(XNOOP,E0,ETOP1));
END "procedure with arguments";
!!EXPR:TYPE[EF]←SYMBOL:TYPE[PRSYM];
RETURN(EF);
END "prcode";
! checks that PRSYM points to a typed procedure ;
RECURSIVE RPTR(!!EXPR)PROCEDURE VPRCODE(RPTR(SYMBOL)PRSYM);
IF SYMBOL:TYPE[PRSYM]=#PR
THEN ERROR(SYMBOL:PNAME[PRSYM]&" cannot return a value and cannot be used here")
ELSE RETURN(PRCODE(PRSYM));
! buffer definitions, ipush,fpush,gpush,ppush,cpush;
INTEGER ARRAY $BUFFER[1:1000];
INTEGER $BUFFERPTR;
! pushes integer J into the buffer ;
SIMPLE PROCEDURE IPUSH(INTEGER J);
$BUFFER[$BUFFERPTR←$BUFFERPTR+1]←J;
! pushes 11 representation of real value R into buffer ;
SIMPLE PROCEDURE FPUSH(REAL R);
BEGIN
FLTOUT(R,$BUFFER[$BUFFERPTR+1],$BUFFER[$BUFFERPTR+2]);
$BUFFERPTR←$BUFFERPTR+2;
END;
! pushes code to do a gtval ;
PROCEDURE GPUSH(RPTR(SYMBOL)S);
BEGIN INTEGER I;
IF SYMBOL:INDEX[S]>0
THEN FOR I←XAGTVAL,SYMBOL:INDEX[S],SYMBOL:OFFSET[S] DO IPUSH(I)
ELSE FOR I←XGTVAL,SYMBOL:OFFSET[S] DO IPUSH(I);
END;
PROCEDURE CPUSH(RPTR(SYMBOL)S);
BEGIN INTEGER I;
IF SYMBOL:INDEX[S]>0
THEN FOR I←XACHNGE,SYMBOL:INDEX[S],SYMBOL:OFFSET[S] DO IPUSH(I)
ELSE FOR I←XCHNGE,SYMBOL:OFFSET[S] DO IPUSH(I);
END;
PROCEDURE PPUSH(RPTR(SYMBOL)S);
IF SYMBOL:INDEX[S]>0 THEN
BEGIN IPUSH(XPUSHINTI);IPUSH(SYMBOL:INDEX[S]); END;
! αexpr$,βexpr$,nexpr,expr$11,expr$2,expr$off,αten$;
INTERNAL RPTR(TEN$)PROCEDURE αTEN$(INTEGER OP,TYPE(0); RPTR(SYMBOL,FRAME)F1(NULL_RECORD),
F2(NULL_RECORD));
BEGIN
RPTR(TEN$)T; T←NEW_RECORD(TEN$);
TEN$:OP[T]←OP; TEN$:TYPE[T]←TYPE;
TEN$:S1[T]←F1; TEN$:S2[T]←F2;
RETURN(T);
END;
INTERNAL PROCEDURE ADDTEN(RPTR(EXPR$)E;RPTR(TEN$)T);
BEGIN
INTEGER I;
I←EXPR$:#TEN[E]+1;
BEGIN
RPTR(TEN$)ARRAY TEN[1:I];
IF I>1 THEN ARRBLT(TEN[1],EXPR$:TEN$[E][1],I-1);
TEN[I]←T;
MEMORY[LOCATION(EXPR$:TEN$[E])]←MEMORY[LOCATION(TEN)];
MEMORY[LOCATION(TEN)]←0;
END;
EXPR$:#TEN[E]←I;
END;
RPTR (EXPR$)PROCEDURE βEXPR$(INTEGER TYPE(0));
BEGIN
! creates a record EXPR$ with data from the buffer $BUFFER;
RPTR(EXPR$)EE; INTEGER ARRAY BUFF[1:$BUFFERPTR];
ARRBLT(BUFF[1],$BUFFER[1],$BUFFERPTR);
EE←NEW_RECORD(EXPR$);
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
EXPR$:#BODY[EE]←$BUFFERPTR;
EXPR$:TYPE[EE]←TYPE;
$BUFFERPTR←0;
RETURN(EE);
END;
RPTR(EXPR$)PROCEDURE NEXPR(INTEGER SIZE,ARG1);
BEGIN
! produces a record EXPR$ with #BODY=SIZE, and first element=ARG1;
INTEGER ARRAY BUFF[1:SIZE];
RPTR(EXPR$)EE;
BUFF[1]←ARG1;
EE←NEW_RECORD(EXPR$);
EXPR$:#BODY[EE]←SIZE;
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
RETURN(EE);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$1(INTEGER I(0));
RETURN(NEXPR(1,I));
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$2(INTEGER I(0),J(0));
BEGIN
RPTR(EXPR$)E;
E←NEXPR(2,I);
EXPR$:BODY[E][2]←J;
RETURN(E);
END;
INTERNAL RPTR(EXPR$)PROCEDURE EXPR$3(INTEGER I(0),J(0),K(0));
BEGIN
RPTR(EXPR$)E;
E←NEXPR(3,I);
EXPR$:BODY[E][2]←J;
EXPR$:BODY[E][3]←K;
RETURN(E);
END;
INTEGER PROCEDURE EXPR$OFF(RPTR(EXPR$)ARRAY ARR; INTEGER I,J);
BEGIN
INTEGER K,K1;
K←1;
FOR K1←I STEP 1 UNTIL J DO IF ARR[K1] THEN K←K+EXPR$:#BODY[ARR[K1]];
RETURN(K);
END;
RPTR(EXPR$)PROCEDURE EXPR$R(RPTR(SYMBOL)S);
IF SYMBOL:INDEX[S]>0
THEN RETURN(EXPR$3(XARTVAL,SYMBOL:INDEX[S],SYMBOL:OFFSET[S]))
ELSE IF SYMBOL:OFFSET[S]<'1000
THEN RETURN(EXPR$3(XGTVAL,SYMBOL:OFFSET[S],XRTVAL))
ELSE RETURN(EXPR$1(XNOOP));
INTERNAL RPTR (EXPR$) PROCEDURE αEXPR$(INTEGER ARRAY BUFFER;INTEGER #TYPE);
BEGIN
! creates a record EXPR$ with data the contents of BUFFER;
RPTR(EXPR$) EE; INTEGER I;
I←ARRINFO(BUFFER,2);
BEGIN
INTEGER ARRAY BUFF[1:I];
ARRTRAN(BUFF,BUFFER);
EE←NEW_RECORD(EXPR$);
MEMORY[LOCATION(EXPR$:BODY[EE])]↔MEMORY[LOCATION(BUFF)];
EXPR$:#BODY[EE]←I;
END;
EXPR$:TYPE[EE]←#TYPE;
RETURN(EE);
END;
! mkexpr,gtexpr,aref,idref,pref;
RPTR(EXPR$) PROCEDURE MKEXPR(INTEGER BUFSIZ;RPTR(!!EXPR)EE);
BEGIN "MKEXPR"
! routine for changing the tree structure form of the expression into
an integer array.
The integer array is returned in EXPR$:BODY;
! Caution : the bro field of the expression EE should be null ;
INTEGER ARRAY BUFFER[1:BUFSIZ]; INTEGER Q; RPTR(EXPR$) $$;
PROCEDURE PUSHBUFFER(INTEGER I);
BUFFER[Q←Q+1]←I;
RECURSIVE PROCEDURE REDUCE(RPTR(!!EXPR)E);
BEGIN
RPTR(!!EXPR)E1;
E1←!!EXPR:SON[E];
WHILE E1≠NULL_RECORD DO
BEGIN REDUCE(E1);
E1←!!EXPR:BRO[E1];
END;
PUSHBUFFER(!!EXPR:OP[E]);
IF !!EXPR:#EL[E]=1 THEN RETURN;
PUSHBUFFER(!!EXPR:X1[E]);
IF !!EXPR:#EL[E]=2 THEN RETURN;
PUSHBUFFER(!!EXPR:X2[E]);
END;
Q←0;
REDUCE(EE);
IF Q≠BUFSIZ THEN ERROR("something is wrong, the string of numbers"&CVS(Q)&" not equal to expected"&CVS(BUFSIZ));
RETURN(αEXPR$(BUFFER,!!EXPR:TYPE[EE]));
END "MKEXPR";
RPTR(EXPR$)PROCEDURE GTEXPR;
BEGIN "GTEXPR"
! driver for MKEXPR;
RPTR(!!EXPR)EE;
##EL←0;
! STOKEN←FALSE;
GGTOKEN;
EE←EXP;
STOKEN←TRUE;
RETURN(MKEXPR(##EL,EE));
END "GTEXPR";
INTERNAL RPTR(EXPR$)PROCEDURE AREF(RPTR(SYMBOL)S;INTEGER OPERATION(XGTVAL));
BEGIN "AREF"
RPTR(!!EXPR)EE;
##EL←0;
EE←ARCODE(S,OPERATION);
RETURN(MKEXPR(##EL,EE));
END "AREF";
INTERNAL RPTR(EXPR$)PROCEDURE PREF(RPTR(SYMBOL)S);
BEGIN
RPTR(!!EXPR)EE;
##EL←0;
EE←PRCODE(S);
RETURN(MKEXPR(##EL,EE));
END;
! produces the EXPR$ record for references to variables
i.e. code to push the desired offset onto the stack ;
ifc false thenc
INTERNAL RPTR(EXPR$)PROCEDURE IDREF(REFERENCE RPTR(SYMBOL)S);
BEGIN "IDREF"
RPTR(!!EXPR)EE;
GGTOKEN;
IF TOKENPTR=NULL_RECORD THEN ERROR("Need identifier here")
ELSE S←TOKENPTR;
##EL←0;
EE←EXP;
IF !!EXPR:OP[EE]=XGTVAL THEN !!EXPR:OP[EE]←XPUSHOFFSET
ELSE IF !!EXPR:OP[EE]=XAGTVAL THEN !!EXPR:OP[EE]←XAPUSHOFFSET
ELSE ERROR("Need an identifier or array element here");
RETURN(MKEXPR(##EL,EE));
END "IDREF";
endc
! $append,$aappend;
INTERNAL RPTR(EXPR$) PROCEDURE $APPEND(RPTR(EXPR$)E1,E2; INTEGER TYPE(0));
BEGIN
! produces a new record concatenating the bodies of the E1 and E2;
RPTR(EXPR$)EE; INTEGER J1,J2,J,K1,K2,K;
IF E1 THEN BEGIN J1←EXPR$:#BODY[E1]; K1←EXPR$:#TEN[E1] END ELSE J1←K1←0;
IF E2 THEN BEGIN J2←EXPR$:#BODY[E2]; K2←EXPR$:#TEN[E2] END ELSE J2←K2←0;
J←J1+J2; K←K1+K2;
IF J>0 THEN
BEGIN INTEGER ARRAY BUFF[1:J];
IF J1 THEN ARRBLT(BUFF[1],EXPR$:BODY[E1][1],J1);
IF J2 THEN ARRBLT(BUFF[J1+1],EXPR$:BODY[E2][1],J2);
EE←αEXPR$(BUFF,TYPE);
EXPR$:#BODY[EE]←J;
IF K>0 THEN
BEGIN RPTR(TEN$) ARRAY BUFF[1:K];
IF K1 THEN ARRBLT(BUFF[1],EXPR$:TEN$[E1][1],K1);
IF K2 THEN ARRBLT(BUFF[K1+1],EXPR$:TEN$[E2][1],K2);
EXPR$:#TEN[EE]←K;
MEMORY[LOCATION(BUFF)]↔MEMORY[LOCATION(EXPR$:TEN$[EE])];
END;
END;
RETURN(EE);
END;
INTERNAL RPTR(EXPR$) PROCEDURE $AAPPEND(RPTR(EXPR$) ARRAY APTR;INTEGER TYPE(0));
BEGIN RPTR(EXPR$) PTR;
INTEGER LA,UA; LA←ARRINFO(APTR,1); UA←ARRINFO(APTR,2);
BEGIN INTEGER I,BSIZE,TSIZE; INTEGER ARRAY ASIZE,TASIZE[LA:UA];
TSIZE←BSIZE←0;
FOR I←LA STEP 1 UNTIL UA DO
IF APTR[I] THEN BEGIN
BSIZE←BSIZE + (ASIZE[I]←EXPR$:#BODY[APTR[I]]);
TSIZE←TSIZE + (TASIZE[I]←EXPR$:#TEN[APTR[I]]); END;
BEGIN
INTEGER ARRAY BUFF[1:BSIZE]; INTEGER J1;
J1←1;
FOR I←LA STEP 1 UNTIL UA DO
IF ASIZE[I]>0 THEN
BEGIN
ARRBLT(BUFF[J1],EXPR$:BODY[APTR[I]][1],ASIZE[I]);
J1←J1+ASIZE[I];
END;
PTR←NEW_RECORD(EXPR$);
MEMORY[LOCATION(BUFF)] ↔ MEMORY[LOCATION(EXPR$:BODY[PTR])];
EXPR$:#BODY[PTR]←BSIZE;
IF TSIZE THEN
BEGIN
RPTR(TEN$) ARRAY TBUFF[1:TSIZE]; INTEGER T1;
T1←1;
FOR I←LA STEP 1 UNTIL UA DO
IF TASIZE[I]>0 THEN
BEGIN
ARRBLT(TBUFF[T1],EXPR$:TEN$[APTR[I]][1],TASIZE[I]);
T1←T1+TASIZE[I];
END;
MEMORY[LOCATION(TBUFF)] ↔ MEMORY[LOCATION(EXPR$:TEN$[PTR])];
EXPR$:#TEN[PTR]←TSIZE;
END;
END;
END;
EXPR$:TYPE[PTR]←TYPE;
RETURN(PTR);
END;
! pdp10 routines: ,$ASGPCODE;
! leaves value of the trans ;
RPTR(EXPR$)PROCEDURE AFXPCODE(RPTR(SYMBOL)SON,DAD;
INTEGER AFXTYP;RPTR(FRAME)N);
BEGIN
INTEGER I; RPTR(EXPR$)E;
FOR I←XPUSHINTI,FRAME:BYOFFSET[N] DO IPUSH(I);
PPUSH(DAD);PPUSH(SON);
FOR I← XAFFIX,SYMBOL:OFFSET[SON],SYMBOL:OFFSET[DAD],
AFXTYP+'2000,ARROFF[#TR]
DO IPUSH(I);
GPUSH(DAD);CPUSH(DAD);
E←βEXPR$;
RETURN(E);
END;
INTERNAL RPTR(EXPR$) PROCEDURE $AFXPCODE(RPTR(SYMBOL)SON,DAD; INTEGER AFFTYPE;
RPTR(EXPR$)E1);
BEGIN
RPTR(EXPR$)EE;
RPTR(FRAME)N,D;
INTEGER AFFCODE;
N←SYMBOL:OBJECT[SON]; D←SYMBOL:OBJECT[DAD];
AFFCODE←IF AFFTYPE=#RGDLK THEN 0 ELSE '400;
IF E1 THEN
BEGIN
EE←AFXPCODE(SON,DAD,AFFCODE,N);
EE←$APPEND(E1,EE,EXPR$:TYPE[E1]);
END
ELSE BEGIN
EE←AFXPCODE(SON,DAD,AFFCODE+'100000,N);
EXPR$:TYPE[EE]←#FR;
END;
ADDTEN(EE,αTEN$(XXAFFIX,AFFTYPE,N,D));
RETURN(EE);
END;
INTERNAL RPTR(EXPR$) PROCEDURE $UFXPCODE(RPTR(SYMBOL)S,D);
BEGIN
INTEGER I;
RPTR(EXPR$)E1;
GPUSH(S);CPUSH(S);GPUSH(D);CPUSH(D);
PPUSH(D);PPUSH(S);
FOR I← XUNFIX, SYMBOL:OFFSET[S],SYMBOL:OFFSET[D] DO IPUSH(I);
E1←βEXPR$(#FR);
ADDTEN(E1,αTEN$(XXUNFIX,0,S,D));
RETURN(E1);
END;
INTERNAL RPTR(EXPR$) PROCEDURE $ASGPCODE(RPTR(EXPR$) EXPR; RPTR(SYMBOL)S);
BEGIN
RPTR(EXPR$)ARRAY PTR[1:3];
RPTR(EXPR$)E2; INTEGER TYPE;
PTR[1]←$ARMPCODE; ! update arm positions ;
PTR[2]←EXPR; ! compute the expression ;
CPUSH(S);
PTR[3]←βEXPR$(TYPE←SYMBOL:TYPE[S]); ! assign the variable ;
IF SYMBOL:INDEX[S]>0 THEN ADDTEN(PTR[3],αTEN$(XXASSIGN,TYPE,S));
RETURN($AAPPEND(PTR,TYPE));
END;
INTERNAL RPTR(EXPR$) PROCEDURE $AASGPCODE(RPTR(EXPR$)E1,E2);
BEGIN
RPTR(EXPR$)ARRAY PTR[1:3];
PTR[1]←$ARMPCODE; ! update arm positions ;
PTR[2]←E2; ! compute the expression ;
PTR[3]←E1; ! assign the variable ;
RETURN($AAPPEND(PTR));
END;
! printing: prnpcode,prvpcode,ddt;
INTERNAL RPTR(EXPR$) PROCEDURE $PRVPCODE(RPTR(EXPR$)E);
RETURN($APPEND(E,EXPR$1(XVALPRN),EXPR$:TYPE[E]));
INTERNAL RPTR(EXPR$)PROCEDURE $PRNPCODE(STRING S);
BEGIN
RPTR(EXPR$) ARRAY PRN[1:3]; INTEGER I;
PRN[1]←EXPR$2(XRJMP);
DO IPUSH(LOP(S)+ (I←LOP(S)) LSH 8) UNTIL I=0;
PRN[2]←βEXPR$;
PRN[3]←EXPR$2(XRPRINT);
EXPR$:BODY[PRN[1]][2]←EXPR$OFF(PRN,2,2);
EXPR$:BODY[PRN[3]][2]←-EXPR$OFF(PRN,2,2);
RETURN($AAPPEND(PRN));
END;
INTERNAL RPTR(EXPR$) PROCEDURE $DDTPCODE;
RETURN(EXPR$1(XDDT));
! motion:$centerpcode,$movepcode,$drivepcode,rforcepcode;
PRESET_WITH '100000,'40000,'20000,'10000,'4000,'2000,'1000,
'400,'200,'100,'40,'20,'10,'4;
INTEGER ARRAY JT_CODE[0:1,1:7];
INTERNAL RPTR(EXPR$)PROCEDURE $DRIVEPCODE(INTEGER COLOR;STRING HOW;
INTEGER JOINT;RPTR(EXPR$)SCAL);
BEGIN RPTR(EXPR$)E;
INTEGER I;
FOR I←XCHNGE,$TSCOFF,XRJMP,9,
JT_CODE[COLOR,JOINT],0,0,0, $TSCOFF,0,0,0,
(IF EQU(HOW,"BY") THEN XRTDDRIVE ELSE XRTADRIVE),
-9,
(IF 1≤JOINT≤6
THEN IF COLOR=BLUE THEN BARM_MECH
ELSE YARM_MECH
ELSE IF COLOR=BLUE THEN BHAND_MECH
ELSE YHAND_MECH)
DO IPUSH(I);
E←$APPEND(SCAL,βEXPR$);
ADDTEN(E,αTEN$(XXMOVE));
RETURN(E);
END;
INTERNAL RPTR(EXPR$)PROCEDURE $MOVEPCODE(RPTR(SYMBOL)S1,S2;
RPTR(EXPR$)ARRAY FDESTS; INTEGER NFDEST);
BEGIN
RPTR(EXPR$) ARRAY BDESTS[0:NFDEST],PTR[1:5];
RPTR(EXPR$) PPTR;
INTEGER I,J,INDEX;
PTR[1]←$ARMPCODE;
J←$TTROFF;
GPUSH(S1);
IPUSH(XTINVRT);
GPUSH(S2);
FOR I← XTTMUL,
XCHNGE, J
DO IPUSH(I);
BDESTS[0]←βEXPR$;
FOR I←1 STEP 1 UNTIL NFDEST
DO BEGIN INTEGER I1;
FOR I1←XGTVAL,J,XTTMUL, XCHNGE,J+I DO IPUSH(I1);
BDESTS[I]←$APPEND(FDESTS[I],βEXPR$,0);
END;
PTR[2]←$AAPPEND(BDESTS);
PTR[3]←EXPR$2(XRJMP);
FOR I←BARMSB,0,0,0 DO IPUSH(I);
FOR I←1 STEP 1 UNTIL NFDEST DO
BEGIN
IPUSH(J+I); IPUSH(0);IPUSH(0)
END;
IPUSH(0);
PTR[4]←βEXPR$;
EXPR$:BODY[PTR[3]][2]←EXPR$OFF(PTR,4,4);
FOR I←XRPMOVE, - (EXPR$:#BODY[PTR[4]]+1),
BARM_MECH
DO IPUSH(I);
PTR[5]←βEXPR$;
PPTR←$AAPPEND(PTR);
ADDTEN(PPTR,αTEN$(XXMOVE,0,S1));
RETURN(PPTR);
END;
INTERNAL RPTR(EXPR$) PROCEDURE $CENTERPCODE(INTEGER ARM);
BEGIN "CENTER"
INTEGER I;
RPTR(EXPR$) PTR;
FOR I←XRJMP,8,
(IF ARM=BLUE THEN (BARMSB+BHANDSB) ELSE (YHANDSB+YARMSB)),
0,0,0,0,0,0,
XRCENTER,- 8,
(IF ARM=BLUE THEN BARM_MECH+BHAND_MECH ELSE YARM_MECH+YHAND_MECH)
DO IPUSH(I);
PTR←$APPEND($ARMPCODE,βEXPR$,0);
ADDTEN(PTR,αTEN$(XXMOVE));
RETURN(PTR);
END "CENTER";
INTERNAL RPTR(EXPR$) PROCEDURE $RFORCEPCODE;
BEGIN "RFORCE"
RPTR(EXPR$) PTR;
PTR←EXPR$1(XRFORCE);
ADDTEN(PTR,αTEN$(XXRFORCE));
RETURN(PTR);
END "RFORCE";
! control pcodes: if,for,while,do;
INTERNAL RPTR(EXPR$)PROCEDURE $IFPCODE(RPTR(EXPR$) COND,A,B(NULL));
BEGIN
RPTR(EXPR$)ARRAY IFP[1:6];
IFP[1]←COND;
IFP[2]←EXPR$2(XRJMPC);
IFP[3]←A;
IFP[4]←EXPR$2(XRJMP);
IFP[5]←IF B THEN B ELSE EXPR$1(XNOOP);
IFP[6]←EXPR$1(XNOOP);
EXPR$:BODY[IFP[2]][2]←EXPR$OFF(IFP,3,4);
EXPR$:BODY[IFP[4]][2]←EXPR$OFF(IFP,5,5);
RETURN($AAPPEND(IFP));
END;
INTERNAL RPTR(EXPR$)PROCEDURE $WHILEPCODE(RPTR(EXPR$)COND,STAT);
BEGIN
RPTR(EXPR$)ARRAY WHP[1:5];
WHP[1]←COND;
WHP[2]←EXPR$2(XRJMPC);
WHP[3]←STAT;
WHP[4]←EXPR$2(XRJMP);
WHP[5]←EXPR$1(XNOOP);
EXPR$:BODY[WHP[2]][2]←EXPR$OFF(WHP,3,4);
EXPR$:BODY[WHP[4]][2]←-EXPR$OFF(WHP,1,3);
RETURN($AAPPEND(WHP));
END;
INTERNAL RPTR(EXPR$)PROCEDURE $DOPCODE(RPTR(EXPR$)S,B);
BEGIN
RPTR(EXPR$)ARRAY DOP[1:3];
DOP[1]←S;
DOP[2]←B;
DOP[3]←EXPR$2(XRJMPC,-EXPR$OFF(DOP,1,2));
RETURN($AAPPEND(DOP));
END;
INTERNAL RPTR(EXPR$)PROCEDURE $FORPCODE(RPTR(SYMBOL)K;RPTR(EXPR$)I1,I2,I3,S);
BEGIN
RPTR(EXPR$) ARRAY FORP[1:9]; INTEGER I;
FORP[1]←I1;
FORP[2]←I3;
FORP[3]←I2;
FOR I←XCOPY,2 DO IPUSH(I);
CPUSH(K);
FORP[4]←βEXPR$;
ADDTEN(FORP[4],αTEN$(XXASSIGN,#SC,K));
FORP[5]←EXPR$2(XRFRCHK);
FORP[6]←S;
FOR I←XCOPY,0,XCOPY,3,XSADD,XREPLAC,3 DO IPUSH(I);
FORP[7]←βEXPR$;
FORP[8]←EXPR$2(XRJMP);
FORP[9]←EXPR$3(XPOP,XPOP,XPOP);
EXPR$:BODY[FORP[8]][2]←-EXPR$OFF(FORP,4,7);
EXPR$:BODY[FORP[5]][2]←EXPR$OFF(FORP,6,8);
RETURN($AAPPEND(FORP));
END;
! arrdclpcode,prcdclpcode,rtnpcode,smpdclpcode;
INTERNAL RPTR(EXPR$)PROCEDURE $SMPDCLPCODE(INTEGER OBTYPE,J);
BEGIN
INTEGER I;
FOR I←XMVAR, OBTYPES[OBTYPE], J, 0 DO IPUSH(I);
RETURN(βEXPR$(OBTYPE));
END;
INTERNAL RPTR(EXPR$)PROCEDURE $KVARPCODE(INTEGER N);
IF N>0 THEN RETURN(EXPR$2(XKVAR,N)) ELSE RETURN(EXPR$1(XNOOP));
INTERNAL RPTR(EXPR$)PROCEDURE $RTNPCODE(RPTR(EXPR$)EE);
BEGIN
RPTR(EXPR$)E;
INTEGER I,TYP,VAL;
IF EE=NULL!RECORD THEN
BEGIN VAL←0; TYP←#PR END
ELSE BEGIN VAL←#MINUS1; TYP←EXPR$:TYPE[EE]; END;
FOR I←XRETURN,VAL DO IPUSH(I);
E←βEXPR$;
E←$APPEND(EE,E,TYP);
RETURN(E);
END;
INTERNAL RPTR(EXPR$)PROCEDURE $PRCDCLPCODE(RPTR(SYMBOL)SYM; RPTR(EXPR$)PBODY);
BEGIN
INTEGER NARGS,ENV;
RPTR(EXPR$) ARRAY PTR[1:5];
RPTR(EXPR$)PPTR;
RPTR(PROC)P;
INTEGER I,IPC;
! STRING NAME; INTEGER OBTYPE;
! NAME←SYMBOL:PNAME[SYM];
OBTYPE←SYMBOL:TYPE[SYM];
NARGS←PROC:NARGS[P←SYMBOL:OBJECT[SYM]];
ENV←NARGS; ! include the local variables too ;
IPC← - 1 ; ! dummy to get PPCODE to print out ;
PTR[1]←EXPR$2(XGTBLK);
PTR[2]←PBODY;
PTR[3]←EXPR$2(XRETURN);
IF SYMBOL:TYPE[CURPROC]≠#PR THEN EXPR$:BODY[PTR[3]][2]←#MINUS1;
EXPR$:BODY[PTR[1]][2]←EXPR$OFF(PTR,2,3)-1;
PTR[4]←EXPR$1(5);
FOR I←XMVAR,#PRCTYP,1,NARGS,IPC,ENV+30 DO IPUSH(I);
FOR I←1 STEP 1 UNTIL NARGS DO IPUSH(PROC:ARGACCS[P][I]
+OBTYPES[PROC:ARGTYPE[P][I]]);
IPUSH(0); ! indicate end of mvar pcode;
PTR[5]←βEXPR$(OBTYPE); ! this is the procedure header ;
PPTR←$AAPPEND(PTR);
ADDTEN(PPTR,αTEN$(XXPRCDECL,0,SYM));
RETURN(PPTR);
END;
INTERNAL RPTR(EXPR$) PROCEDURE $ARRDCLPCODE(STRING NAME;
RPTR(EXPR$)ARRAY BOUNDS; INTEGER OBTYPE,ADIM);
BEGIN
RPTR(EXPR$) ARRAY $BOUNDS[1:4*ADIM+1];
RPTR(EXPR$) PTR; RPTR(SYMBOL)S; RPTR(ARRAYREC)A;
INTEGER I,I1,I2,J;
J←$TSCOFF-1; I2←0;
FOR I←1 STEP 1 UNTIL 2*ADIM DO
BEGIN
IF EXPR$:TYPE[BOUNDS[I]]≠#SC THEN ERROR("Need scalar expression for bounds of array");
$BOUNDS[I2←I2+1]←BOUNDS[I];
FOR I1←XCOPY,0,XCHNGE,J+I,XRTVAL DO IPUSH(I1);
$BOUNDS[I2←I2+1]←βEXPR$;
END;
FOR I1←XMVAR,#ARRTYP + OBTYPES[OBTYPE],ADIM DO IPUSH(I1);
FOR I1←2 STEP 2 UNTIL ADIM*2 DO BEGIN IPUSH(J+I1); IPUSH(J+I1-1); END;
IPUSH(0);
$BOUNDS[I2←I2+1]←βEXPR$;
PTR←$AAPPEND($BOUNDS,OBTYPE);
S←NEW_RECORD(SYMBOL);
SYMBOL:PNAME[S]←NAME;
SYMBOL:TYPE[S]←OBTYPE;
SYMBOL:ACCESS[S]←#ARRAY;
SYMBOL:OBJECT[S]←A←NEW_RECORD(ARRAYREC);
ARRAYREC:#DIM[A]←ADIM;
IF CURBLOCK
THEN ADDTEN(PTR,αTEN$(XXARRDECL2,ADIM,S))
ELSE ADDTEN(PTR,αTEN$(XXARRDECL,ADIM,S));
RETURN(PTR);
END;
! mssngr buffer procedures: getfp,getfpa,getin,getina ;
SIMPLE REAL PROCEDURE GETFP;
RETURN($FPBUF[$FPPTR←$FPPTR+1]);
SIMPLE PROCEDURE GETFPA(REAL ARRAY A; INTEGER NDATA);
BEGIN
ARRBLT(A[1],$FPBUF[$FPPTR+1],NDATA);
$FPPTR←$FPPTR+NDATA;
END;
SIMPLE INTEGER PROCEDURE GETIN;
RETURN($INBUF[$INTPTR←$INTPTR+1]);
SIMPLE PROCEDURE GETINA(INTEGER ARRAY A; INTEGER NDATA);
BEGIN
ARRBLT(A[1],$INBUF[$INTPTR+1],NDATA);
$INTPTR←$INTPTR+NDATA;
END;
! assgmnt,unfixment,affixment,teninterpret;
RPTR(FRAME) PROCEDURE OLDEST_RIGID_ANCESTOR(RPTR(FRAME)F);
BEGIN
RPTR(FRAME)D; D←F;
WHILE FRAME:HOWLINKED[D]=#RGDLK DO D←FRAME:DAD[D];
RETURN(D);
END;
PROCEDURE ASSGMNT(RPTR(TEN$)T);
BEGIN
RANY S;
S←SYMBOL:OBJECT[TEN$:S1[T]];
IF SYMBOL:OFFSET[TEN$:S1[T]]<'1000 THEN
CASE TEN$:TYPE[T] OF
BEGIN
[#SC] SCALAR:VALUE[S]←GETFP;
[#VT] BEGIN
VECTOR:XC[S]←GETFP;
VECTOR:YC[S]←GETFP;
VECTOR:ZC[S]←GETFP;
END;
[#RT] GETFPA(ROT:XF[S],6);
[#TR] GETFPA(TRANS:XF[S],6);
[#FR] GETFPA(FRAME:XF[OLDEST_RIGID_ANCESTOR(S)],6);
ELSE ERROR("error in assgment")
END;
IF $FPPTR>$FPSIZ THEN ERROR("overran answer buffer");
IF $INTPTR>$INTSIZ THEN ERROR("overran control buffer");
$DISPLAYLIST[TEN$:TYPE[T]]←NULL;
END;
PROCEDURE UNFIXMENT(RPTR(TEN$)T);
BEGIN
GETFPA(FRAME:XF[SYMBOL:OBJECT[TEN$:S1[T]]],6);
UFX_NODE(SYMBOL:OBJECT[TEN$:S1[T]],SYMBOL:OBJECT[TEN$:S2[T]]);
$FRLST←NULL;
END;
PROCEDURE AFFIXMENT(RPTR(TEN$)T);
BEGIN
GETFPA(FRAME:XF[TEN$:S1[T]],6);
AFX_NODE(TEN$:S1[T],TEN$:S2[T],TEN$:TYPE[T]); ! affixes n to d;
$FRLST←NULL;
END;
SIMPLE INTEGER PROCEDURE COUNTBITS(INTEGER BITS);
BEGIN INTEGER I,J,K;
I←0;
J←BITS LAND '177777;
FOR K←1 STEP 1 UNTIL 16 DO
BEGIN
I←I + (J LAND 1);
J←J LSH -1;
END;
RETURN(I);
END;
PROCEDURE MOVE(RPTR(TEN$)T);
BEGIN INTEGER CODE,SIZE,BITS,PNTS;
CODE←GETIN;
IF CODE≠XMOVE THEN ERROR("expect move pcode result");
BITS←GETIN;
PNTS←GETIN;
SIZE←COUNTBITS(BITS)*PNTS;
IF SIZE>0 THEN
BEGIN
REAL ARRAY A[1:SIZE];
RPTR(GRAPHREC) G;
G←NEW_RECORD(GRAPHREC);
GRAPHREC:CTLBITS[G]←BITS;
GRAPHREC:NPNTS[G]←PNTS;
GRAPHREC:SIZE[G]←SIZE;
GETFPA(A,SIZE);
MEMORY[LOCATION(GRAPHREC:DATA[G])]↔MEMORY[LOCATION(A)];
GRAPTR←G;
END;
$FRLST←$SCLST←$DFLST←NULL;
END;
PROCEDURE RFORCE(RPTR(TEN$)T);
BEGIN INTEGER ARRAY DAT[1:10,1:9],DATA[1:90];
INTEGER CODE;
IF (CODE←GETIN)≠XRFORCE THEN ERROR("wrong response for xrforce");
GETINA(DATA,90);
ARRBLT(DAT[1,1],DATA[1],90);
WSTPTR←NEW_RECORD(WRISTREC);
MEMORY[LOCATION(WRISTREC:DATA[WSTPTR])]↔MEMORY[LOCATION(DAT)];
END;
PROCEDURE PRCDECL(RPTR(TEN$)T);
BEGIN
ENSYM$(TEN$:S1[T]);
$SYMOFF←$SYMOFF+1;
END;
PROCEDURE ARRDECL2(RPTR(TEN$)T);
$FPPTR←$FPPTR+2*TEN$:TYPE[T];
PROCEDURE ARRDECL(RPTR(TEN$)T);
BEGIN
INTEGER ARRAY LB,UB[1:TEN$:TYPE[T]];
RPTR(SYMBOL)TEMP; INTEGER I;
FOR I←1 STEP 1 UNTIL TEN$:TYPE[T]
DO BEGIN
LB[I]←GETFP;
UB[I]←GETFP;
END;
ENSYM$(TEMP←NWAREC(TEN$:S1[T],LB,UB));
SYMBOL:OFFSET[TEMP]←$SYMOFF;$SYMOFF←$SYMOFF+1;
END;
PROCEDURE TENINTERPRET(RPTR(TEN$)T);
CASE TEN$:OP[T] OF
BEGIN
[XXASSIGN] ASSGMNT(T);
[XXAFFIX] AFFIXMENT(T);
[XXUNFIX] UNFIXMENT(T);
[XXMOVE] MOVE(T);
[XXARRDECL] ARRDECL(T);
[XXARRDECL2] ARRDECL2(T);
[XXPRCDECL] PRCDECL(T);
[XXRFORCE] RFORCE(T);
ELSE ERROR("error in teninterpret")
END;
! $execute,$elfeval,$$gtvexpr,$$gtexpr;
RECURSIVE RPTR(EXPR$) PROCEDURE $ELFEVAL(RPTR(EXPR$)CUEXPR);
BEGIN
RPTR(EXPR$)ELFX,ELFX1; INTEGER J;
RPTR(EXPR$)ARRAY PTR[1:5];
PTR[1]←CUEXPR;
IF (J←EXPR$:#TEN[CUEXPR])>0 THEN
BEGIN INTEGER I; RPTR(EXPR$)ARRAY PPTR[1:J]; RPTR(TEN$)T;
FOR I←1 STEP 1 UNTIL J DO
IF (T←EXPR$:TEN$[CUEXPR][I])
THEN CASE TEN$:OP[T] OF
α
[XXASSIGN] IF TEN$:TYPE[T]≠#FR THEN
PPTR[I]←EXPR$R(TEN$:S1[T])
ELSE BEGIN
RPTR(FRAME)D,S;
S←SYMBOL:OBJECT[TEN$:S1[T]];
D←OLDEST_RIGID_ANCESTOR(S);
IF FRAME:DAD[D]=F_WRLD THEN
PPTR[I]←EXPR$R(FRAME:SYM[D])
ELSE PPTR[I]←EXPR$3(XARTVAL,FRAME:BYOFFSET[D], ARROFF[#FR]);
END;
[XXAFFIX] PPTR[I]←EXPR$3(XARTVAL,FRAME:BYOFFSET[TEN$:S1[T]],
ARROFF[#FR]);
[XXUNFIX] PPTR[I]←EXPR$R(TEN$:S1[T]);
[XXRFORCE]
[XXMOVE] PPTR[I]←$ARMPCODE;
[XXARRDECL]
[XXARRDECL2]
[XXPRCDECL] PPTR[I]←EXPR$1(XNOOP);
ELSE BEGIN PRINT("Unexpected tenop, assume noop");
PPTR[I]←EXPR$1(XNOOP);
END
β;
PTR[2]←$AAPPEND(PPTR);
END
ELSE PTR[2]←NULL_RECORD;
PTR[3]←$BHDUPDATE;
PTR[4]←$BRMUPDATE;
PTR[5]←EXPR$1(XPDONE);
ELFX←$AAPPEND(PTR,EXPR$:TYPE[CUEXPR]);
EVAL(ELFX);
RETURN(ELFX);
END;
INTERNAL RECURSIVE PROCEDURE $EXECUTE(RPTR(EXPR$)CUEXPR);
BEGIN
INTEGER I;
RPTR(EXPR$)ELFX;
ELFX←$ELFEVAL(CUEXPR); ! evaluate the expression on the ELF;
IF EXPR$:#TEN[ELFX]>0 THEN
FOR I←1 STEP 1 UNTIL EXPR$:#TEN[ELFX] DO
TENINTERPRET(EXPR$:TEN$[ELFX][I]);
IF ($FPPTR≠$FPSIZ) OR ($INTPTR≠$INTSIZ)
THEN ERROR("error in $execute, numbers left over ");
END;
INTERNAL RECURSIVE RPTR(EXPR$) PROCEDURE $$GTVEXPR;
RETURN($ELFEVAL(GTEXPR));
INTERNAL RPTR(EXPR$) PROCEDURE $$GTEXPR;
RETURN(GTEXPR);
END "FEXPR";